(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\w-Computations"]


ar[i_,j_] := t[i]h[j]; R[i_, j_] := W[1]+ar[i,j](E^c[i]-1)/c[i];


\[Mu]Collect[\[Mu]_] := Collect[\[Mu], _h, Collect[#, _t, Simplify]&] /. W[ws_] :> W[Simplify[ws]];
SetAttributes[\[Mu]Form, Listable];
\[Mu]Form[\[Mu]_] := Module[
{tails, heads, mat},
tails = Union[Cases[\[Mu], t[s_] :> s, Infinity]];
heads = Union[Cases[\[Mu], h[s_] :> s, Infinity]];
mat = Outer[FullSimplify[Coefficient[\[Mu], h[#1] t[#2]]]&, heads, tails];
PrependTo[mat, t /@ tails];
mat = Prepend[Transpose[mat],
Prepend[h /@ heads, \[Mu] /. (h[_]|t[_]) -> 0]
];
MatrixForm[mat]
]


tm[x_,y_,z_][\[Mu]_] := \[Mu]Collect[\[Mu] /. {t[x]|t[y] -> t[z], c[x]|c[y] -> c[z]}];
t\[CapitalDelta][z_, x_, y_][\[Mu]_] := \[Mu]Collect[\[Mu] /. {t[z] -> t[x]+t[y], c[z] -> c[x]+c[y]}];
tS[x_][\[Mu]_] := \[Mu]Collect[\[Mu] /. {t[x] -> -t[x], c[x] -> -c[x]}];


hm[x_,y_,z_][\[Mu]_] := Module[
{\[Xi], \[Eta]},
\[Xi] = D[\[Mu], h[x]];
\[Eta] = D[\[Mu], h[y]];
\[Mu]Collect[(\[Mu] /. h[x|y]->0) + \[Xi] h[z] + (1+\[Xi] /. t[s_]:>c[s])\[Eta] h[z]]
];
h\[CapitalDelta][z_, x_, y_][\[Mu]_] := \[Mu]Collect[\[Mu] /. h[z] -> h[x]+h[y]];
hS[x_][\[Mu]_] := Module[{\[Beta]},
\[Beta] = 1 + D[\[Mu], h[x]] /. t[s_]:>c[s];
\[Mu]Collect[\[Mu] /. h[x] -> -h[x]/\[Beta]]
];


hfac[z_, xtails_List -> x_, y_][\[Mu]_] := Module[
{ytails},
ytails = Complement[
Union[Cases[\[Mu], t[s_] :> s, Infinity]],
xtails
];
hfac[z,xtails -> x, ytails -> y][\[Mu]]
];
hfac[z_, x_,  ytails_List -> y_][\[Mu]_] := Module[
{xtails},
xtails = Complement[
Union[Cases[\[Mu], t[s_] :> s, Infinity]],
ytails
];
hfac[z,xtails -> x, ytails -> y][\[Mu]]
];
hfac[z_, xtails_List -> x_, ytails_List -> y_][\[Mu]_] := Module[
{\[Zeta], \[Xi], \[Eta]},
\[Zeta] = D[\[Mu], h[z]];
\[Xi] = \[Zeta] /. ((t[#]->0)& /@ ytails);
\[Eta] = \[Zeta] /. ((t[#]->0)& /@ xtails);
\[Mu]Collect[\[Mu]-h[z]\[Zeta] + h[x]\[Xi] + h[y]\[Eta]/(1+\[Xi] /. t[s_]->c[s])]
]


conj[y_,x_][\[Mu]_] := Module[
{\[Nu], x0, x1, \[Gamma], \[Xi], \[Eta], a},
\[Nu] = \[Mu] // hfac[x, {y} -> x0, x1];
\[Gamma] = Coefficient[\[Nu], ar[y,x0]];
\[Nu] = \[Mu]Collect[\[Nu] /. W[ws_] :> W[ws*(c[y]\[Gamma]+1)]];
\[Xi] = D[\[Nu], h[x1]];
\[Eta] = D[\[Nu], t[y]];
a = 1 + \[Xi] /. t[s_] :> c[s];
\[Nu] = \[Mu]Collect[(\[Nu] /. t[y] -> a t[y]) -c[y] \[Xi] \[Eta]];
\[Nu] // hm[x0,x1,x]
];
conji[y_,x_][\[Mu]_] := \[Mu] // hS[x] // conj[y,x] // hS[x];


dm[x_,y_,z_][\[Mu]_] := \[Mu] // conji[y,x] // hm[x,y,z] // tm[x,y,z];
d\[CapitalDelta][z_, x_, y_][\[Mu]_] := \[Mu] // h\[CapitalDelta][z,x,y] // t\[CapitalDelta][z,x,y];
dS[x_][\[Mu]_] := \[Mu] // tS[x] // conj[x,x] // hS[x];


Unprotect[NonCommutativeMultiply];
\[Mu]_ ** \[Nu]_ := Module[
{\[Rho], \[Sigma], labels},
\[Rho] = \[Mu] + (\[Nu] /. {h[s_] :> h[\[Sigma][s]], t[s_] :> t[\[Sigma][s]], c[s_] :> c[\[Sigma][s]]});
\[Rho] = \[Rho] /. {
2W[a_] :> W[Simplify[a^2]],
W[a_]+W[b_] :> W[Simplify[a*b]]
};
labels = Union[Cases[{\[Mu],\[Nu]}, h[s_]|t[s_]|c[s_] :> s, Infinity]];
Do[
\[Rho] = \[Rho] // dm[s, \[Sigma][s], s],
{s, labels}
];
\[Rho]
]



